home *** CD-ROM | disk | FTP | other *** search
/ Pascal Super Library / Pascal Super Library (CW International)(1997).bin / LIBRARY / PAS_0693 / MOVEFILE.PAS < prev    next >
Pascal/Delphi Source File  |  1993-06-30  |  7KB  |  165 lines
  1. {─ Fido Pascal Conference ────────────────────────────────────────────── PASCAL ─
  2. Msg  : 521 of 613
  3. From : Eef Hartman                         2:281/613.0          11 Jun 93  08:51
  4. To   : Louis H. Nemec                      1:109/804.0
  5. Subj : File handling
  6. ────────────────────────────────────────────────────────────────────────────────
  7. On 03-Jun-93 13:28 Louis H. Nemec (1:109/804) wrote to Kelly Small:
  8.  
  9.  LHN> BUT how you do it across drives? (From c to d for instance.) You
  10.  LHN> cannot rename across drives.
  11.  
  12. Physically COPY it, than delete the original afterwards.
  13. I once wrote a complete "MOVE" command, but it's much to big to post here and
  14. DOS 6 got its own now anyway.
  15. But the heart of it was:}
  16.  
  17.    PROCEDURE kopieer (VAR orig: padstr;VAR nieuw: padstr;VAR fout: BOOLEAN);
  18.    { Copy file through DOS if not on same disk. Retain original date, time
  19.      and size and delete the original. }
  20.  
  21.       CONST bufsize = $C000;            { About 48 KB }
  22.  
  23.       VAR   regset: registers;          { Registers record for DOS calls }
  24.             src,dst: INTEGER;
  25.             aantal,grootte: LONGINT;
  26.             buffer: ARRAY[1..bufsize] OF BYTE;
  27.  
  28.       PROCEDURE delfile (VAR padnaam: padstr;VAR fout: BOOLEAN);
  29.  
  30.          VAR   regset: registers;       { Registers record for DOS calls }
  31.  
  32.          BEGIN
  33.             WITH regset do BEGIN
  34.                ah := $43;               { Make file R/W for delete }
  35.                al := 1;
  36.                cx := 0;                 { Normal file }
  37.                ds := Seg(padnaam[1]);   { Padnaam is the fully qualified }
  38.                dx := Ofs(padnaam[1]);   { pathname of file, 0 terminated }
  39.                MsDos (regset);
  40.                fout := (flags AND 1) <> 0;
  41.                IF fout THEN
  42.                   WriteLn ('Change attribute error: ',padnaam)
  43.                ELSE BEGIN
  44.                   ah := $41;            { Delete file through padnaam }
  45.                   { ds:dx stil valid from set-attributes }
  46.                   MsDos (regset);
  47.                   IF (flags AND 1) <> 0 THEN BEGIN
  48.                      fout := TRUE;
  49.                      WriteLn ('Delete error: ',padnaam)
  50.                      END
  51.                   END
  52.                END
  53.          END;
  54.  
  55.       BEGIN
  56.          WITH regset DO BEGIN
  57.             ah := $3D;                  { Open existing file }
  58.             al := 0;                    { Read-only }
  59.             ds := Seg(orig[1]);         { Original filename (from) }
  60.             dx := Ofs(orig[1]);
  61.             MsDos (regset);
  62.             fout := (flags AND 1) <> 0;
  63.             IF fout THEN
  64.                WriteLn ('Open error: ',orig)
  65.             ELSE BEGIN
  66.                src := ax;               { Handle of the file }
  67.  
  68.                ah := $3C;               { Create a new file }
  69.                cx := 0;                 { Start as normal file }
  70.                ds := Seg(nieuw[1]);     { Pathname to move TO }
  71.                dx := Ofs(nieuw[1]);
  72.                MsDos (regset);
  73.                fout := (flags AND 1) <> 0;
  74.                IF fout THEN
  75.                   WriteLn ('Create error: ',nieuw)
  76.                ELSE
  77.                   dst := ax
  78.                END
  79.             END;
  80.  
  81.          grootte := zoekblk.size;       { Size of file, from "find" }
  82.          WHILE (grootte > 0) AND NOT fout DO BEGIN
  83.             IF grootte > bufsize THEN
  84.                aantal := bufsize        { Too big for buffer, use buffer size }
  85.             ELSE
  86.                aantal := grootte;
  87.             WITH regset DO BEGIN
  88.                ah := $3F;               { Read block from file }
  89.                bx := src;
  90.                cx := aantal;
  91.                ds := Seg(buffer);
  92.                dx := Ofs(buffer);
  93.                MsDos (regset);
  94.                fout := (flags AND 1) <> 0;
  95.                IF fout THEN
  96.                   WriteLn ('Read error: ',orig)
  97.                ELSE BEGIN
  98.                   ah := $40;            { Write block to file }
  99.                   bx := dst;
  100.                   { cx and ds:dx still valid from Read }
  101.                   MsDos (regset);
  102.                   fout := (flags AND 1) <> 0;
  103.                   IF fout THEN
  104.                      WriteLn ('Write error: ',nieuw)
  105.                   ELSE IF ax < aantal THEN BEGIN
  106.                      WriteLn ('Disk full');
  107.                      fout := TRUE
  108.                      END
  109.                   ELSE
  110.                      grootte := grootte - aantal
  111.                   END
  112.                END
  113.             END;
  114.  
  115.          IF NOT fout THEN WITH regset DO BEGIN
  116.             ah := $57;                  { Adjust date and time of file }
  117.             al := 1;                    { Set date }
  118.             bx := dst;
  119.             cx := zoekblk.time;         { Out of the "find" }
  120.             dx := zoekblk.date;
  121.             MsDos (regset);
  122.             fout := (flags AND 1) <> 0;
  123.             IF fout THEN
  124.                WriteLn ('Change date/time error: ',nieuw)
  125.             END;
  126.  
  127.          WITH regset DO BEGIN
  128.             ah := $3E;                  { Close all files, even with errors! }
  129.             bx := src;
  130.             MsDos (regset);
  131.             fout := fout OR ((flags AND 1) <> 0);
  132.             ah := $3E;
  133.             bx := dst;
  134.             MsDos (regset);
  135.             fout := fout OR ((flags AND 1) <> 0)
  136.             END;
  137.  
  138.          IF fout THEN BEGIN
  139.             DelFile (nieuw,fout);       { Delete copy }
  140.             fout := TRUE                { We already HAD an error! }
  141.             END
  142.          ELSE WITH regset DO BEGIN
  143.             ah := $43;                  { Set correct attributes to new file }
  144.             al := 1;                    { Change attributes }
  145.             cx := zoekblk.attr;         { Attribute out of "find" }
  146.             ds := Seg(nieuw[1]);
  147.             dx := Ofs(nieuw[1]);
  148.             MsDos (regset);
  149.             fout := (flags AND 1) <> 0;
  150.             IF fout THEN
  151.                WriteLn ('Change attribute error: ',nieuw)
  152.             ELSE
  153.                DelFile (orig,fout)      { Now delete the original }
  154.             END
  155.       END;
  156.  
  157. The rest of the program is commandline handling, handling the wildcards (* and
  158. ?), finding the files TO move, testing if the destination doesn't exist already
  159. and using the $56 "rename" call when they ARE on the same disk.
  160. The program has been working for more than 6 years now.
  161. I originally wrote it in TP 3.0 for DOS 2.xx and 3.x
  162. That's also why it doesn't use BlockRead/Write and/or procedures from the DOS
  163. unit (except for the "Registers" type and the MsDos procedure, as it has been
  164. converted from TP 3 which didn't have anymore DOS services than just the MsDos 
  165. procedure.